#!/usr/bin/perl
#
# Build FUZIX system disk from distributed set of fuzix-*.pkg files
# in the Standalone/filesystem-src and Application directories.
#

# TODO
# validate disk geometry.
# check that package names are unique
# work out package on/off rules
# create some uber-packages
# resolve dependencies?

use strict;
use warnings;
use File::Find;

# package files are in @files
# each entry is a reference to an array in which
# [0] directory
# [1] file
my @file;

# packages are in @pkg
# each entry is a reference to an array in which
# [0] ref to entry in @file from which package was read
# [1]->% attributes - including {pkg}
# [2]->@ entries
my @pkg;

# only these attributes are recognised
my %legal_attr = qw( package 0      if-file 0
                     if-cpu 0       set-cpu 0
                     if-platform 0  set-platform 0
                     enable-pkg  0  disable-pkg  0
                     require-pkg 0);

# only these commands are recognised. Specify number of arguments.
my %cmd = qw( d 2  n 3  f 3  l 2  r 1);

# stores command-line arguments
my %args;

# always try to continue, accumulating errors.
my $error = 0;

cmdline_args();
build_file_list();
build_pkg_list();
resolve_pkg();
gen_ucp();
build_dsk();
exit 0;

############################################################################################
# subroutines.

# create an entry for each package (may be more than one package per file)
sub build_pkg_list {
    my %pkgs; # to check for duplicate package names
    foreach my $x (@file) {
        open IN, "$x->[0]/$x->[1]" or die "ERROR could not open file $x->[0]/$x->[1]\n";
        print "Scanning file $x->[0]/$x->[1]\n" if $args{verbose};
        my $in_pkg = 0;
        my $current = 0;
        while (my $line = <IN>) {
            chomp $line;
            # strip comments..
            $line =~ s/#.*$//;
            # .. and trailing whitespace
            $line =~ s/\s*$//;
            next if $line eq '';
            my @bits = split " ", $line;
            if ($bits[0] eq 'package') {
                # start a new entry
                print "Found package $bits[1]\n";
                if (exists $pkgs{$bits[1]}) {
                    $error = $error + 1;
                    print "ERROR $x->[0]/$x->[1]:$. - duplicate package name $bits[1]\n";
                }
                $pkgs{$bits[1]} = 1;

                my %attr;
                $attr{pkg} = $bits[1];  # special: scalar rather than array ref
                my @cmd;
                $in_pkg = 1;
                push @pkg, [$x, \%attr, \@cmd];
                $current = $#pkg;
            }
            elsif (exists($legal_attr{$bits[0]}) and $in_pkg) {
                # attribute: add it to the %attr hash with its arguments as an array ref
                my $attribute = shift @bits;
                $pkg[$current]->[1]->{$attribute} = \@bits;
            }
            elsif (exists($cmd{$bits[0]}) and $in_pkg) {
                # command: prepend line number (for error reporting) then file it away for later
                unshift @bits, ($.);
                push @{$pkg[$current]->[2]}, \@bits;
            }
            else {
                $error = $error + 1;
                print "ERROR $x->[0]/$x->[1]:$. - unknown command/attribute or no package\n";
            }
        }
        close IN;
    }
    die "ERROR Fix errors and re-run\n" if $error;
}


# build a datastructure representing each package file found in the
# Standalone/filesystem-src/ and Application/ directories.
sub build_file_list {
    my @places = ('.','../../Applications','../../Kernel');
    foreach my $dir (@places) {
        find(\&pkg_file, $dir);
    }
}


# call-back from build_file_list
sub pkg_file {
    if ($_ =~ /^fuzix-.*\.pkg$/) {
        my @entry;
        $entry[0] = $File::Find::dir;
        $entry[1] = $_;
        push @file,\@entry;
    }
}

## [NAC HACK 2016Jun24] bug!! for repeated attribute, should concatenate the arguments. Create test-case
## to validate.

# Work out which packages to enable, and put them in the right order
sub resolve_pkg {
    my $all_pkg = '';
    my %pkg;
    # Pass 1: apply defaults: enable each package unless it is self-disabled. Enable a package
    # specified on the command line. Look for ALL and (if found) note its containing package.
    # Build a hash to reference package entries by name (for use in Pass 3/4)
    foreach my $x (@pkg) {
        my $pkg = $x->[1]->{pkg};
        $pkg{$pkg} = $x;
        my $enabled = 1;
        my $all_here = 0;
        if (exists $x->[1]->{'disable-pkg'}) {
            my @disable = @{$x->[1]->{'disable-pkg'}};
            foreach my $p (@disable) {
                if ($p eq $pkg) {
                    # self-disabled
                    $enabled = 0;
                }
                if ($p eq 'ALL') {
                    $all_here = 1;
                }
            }
        }
        if (exists($args{pkg}) and $args{pkg} eq $pkg) {
            $enabled = 1;
        }
        $x->[1]->{enabled} = $enabled;

        # Only honour ALL in an enabled package
        if ($enabled and $all_here) {
            if ($all_pkg) {
                print "WARNING found ALL in enabled package $pkg and enabled package $all_pkg\n";
            }
            else {
                $all_pkg = $pkg;
            }
        }
    }

    # Pass 2: apply ALL
    foreach my $x (@pkg) {
        if ($all_pkg and ($x->[1]->{pkg} ne $all_pkg)) {
            $x->[1]->{enabled} = 0;
        }
    }

    # Pass 3: for all enabled packages, process any enable-pkg statements. Iterate until stable.
    my $loops = 0;
    my $changes;
    do {
        $changes = 0;
        foreach my $x (@pkg) {
            next if ($x->[1]->{enabled} == 0);
            my $pkg = $x->[1]->{pkg};
            if (exists $x->[1]->{'enable-pkg'}) {
                my @enable = @{$x->[1]->{'enable-pkg'}};
                foreach my $p (@enable) {
                    if (exists $pkg{$p}) {
                        if ($pkg{$p}->[1]->{enabled} == 0) {
                            $changes = $changes + 1;
                            $pkg{$p}->[1]->{enabled} = 1;
                            print "Enabled  package $p\n" if $args{verbose};
                        }
                    }
                    else {
                        print "WARNING package $pkg tried to enable non-found package $p\n"
                    }
                }
            }
        }
        $loops = $loops + 1;
        die "ERROR loop detected. Cannot resolve packages\n" if ($loops > 100);
    } while ($changes != 0);

    # Pass 4: for all enabled packages, process any disable-pkg statements. Don't need to iterate
    # here. Ignore self-disable.
    foreach my $x (@pkg) {
        next if ($x->[1]->{enabled} == 0);
        my $pkg = $x->[1]->{pkg};
        if (exists $x->[1]->{'disable-pkg'}) {
            my @disable = @{$x->[1]->{'disable-pkg'}};
            foreach my $p (@disable) {
                next if $p eq 'ALL'; # ignore reserved package name
                next if $p eq $pkg;  # ignore self-disable
                if (exists $pkg{$p}) {
                    if ($pkg{$p}->[1]->{enabled} == 1) {
                        $pkg{$p}->[1]->{enabled} = 0;
                        print "Disabled package $p\n" if $args{verbose};
                    }
                }
                else {
                    print "WARNING package $pkg tried to disable non-found package $p\n"
                }
            }
        }
    }

    # Pass 5: process if-file, if-cpu, if-platform
    # Need to do a pass to extract set-cpu set-platform then another pass to process the 'if-'
    my %set;
    foreach my $x (@pkg) {
        next if ($x->[1]->{enabled} == 0);
        if (exists $x->[1]->{'set-cpu'}) {
            $set{cpu} = $x->[1]->{'set-cpu'}->[0];
        }
        if (exists $x->[1]->{'set-platform'}) {
            $set{platform} = $x->[1]->{'set-platform'}->[0];
        }
    }

    foreach my $x (@pkg) {
        if (exists($x->[1]->{'if-file'}) and (! -f "$x->[0]->[0]/$x->[1]->{'if-file'}->[0]")) {
            $x->[1]->{enabled} = 0;
        }
        if (exists($set{cpu}) and exists($x->[1]->{'if-cpu'}) and
            ($x->[1]->{'if-cpu'}->[0] ne $set{cpu})) {
            $x->[1]->{enabled} = 0;
        }
        if (exists($set{platform}) and exists($x->[1]->{'if-platform'}) and
            ($x->[1]->{'if-platform'}->[0] ne $set{platform})) {
            $x->[1]->{enabled} = 0;
        }

        print "Resolving package $x->[1]->{pkg}: enabled=$x->[1]->{enabled}\n";
    }

    # [NAC HACK 2016Jun25] futures/todo: dependency handling

}


# work through enabled packages in order, generating the UCP script
sub gen_ucp {
    my %paths;
    my $cur_path = '';
    open OUT, ">ucp-tmp.txt" or die "ERROR could not open file ucp-tmp.txt";
    foreach my $x (@pkg) {
        my $file = "$x->[0]->[0]/$x->[0]->[1]";
        my $enabled = $x->[1]->{enabled};
        next if not $enabled;
        print "Processing package $x->[1]->{pkg}\n";
        foreach my $i (0..$#{$x->[2]}) {
             my ($line, $cmd, $arg1, $arg2, $arg3, $arg4) = @{$x->[2]->[$i]};
             # number of arguments to the command
             my $argn = $#{$x->[2]->[$i]} - 2 + 1;
             if ($argn != $cmd{$cmd}) {
                 $error = $error + 1;
                 print "ERROR $file:$line wrong number of arguments\n";
             }
             else {
                if ($cmd eq 'n') { # node arg1: major arg2: minor arg3: path
                    if (exists $paths{$arg3}) {
                        $error = $error + 1;
                        print "ERROR $file:$line duplicate node $arg3\n";
                    }
                    $arg3 =~ /(.*)\/(.*)$/;
                    my $base = $1;
                    my $node = $2;
                    if (exists($paths{$base}) or ($base eq '')) {
                        # all good
                        $paths{"$base/$node"} = 'd';
                        if ($cur_path ne $base) {
                            $base = $base eq '' ? '/' : $base;
                            print OUT "cd $base\n";
                            $cur_path = $base;
                        }
                        print OUT "mknod $node $arg1, $arg2\n";
                    }
                    else {
                        $error = $error + 1;
                        print "ERROR $file:$line no parent path $base for $arg3\n";
                    }
                }
                elsif ($cmd eq 'd') { # directory arg1: protection arg2: path
                    if (exists $paths{$arg2}) {
                        $error = $error + 1;
                        print "ERROR $file:$line duplicate path $arg2\n";
                    }
                    $arg2 =~ /(.*)\/(.*)$/;
                    my $base = $1;
                    my $dir = $2;
                    if (exists($paths{$base}) or ($base eq '')) {
                        # all good
                        $paths{"$base/$dir"} = 'd';
                        if ($cur_path ne $base) {
                            $base = $base eq '' ? '/' : $base;
                            print OUT "cd $base\n";
                            $cur_path = $base;
                        }
                        print OUT "mkdir $dir\n";
                        print OUT "chmod  $arg1 $dir\n";
                    }
                    else {
                        $error = $error + 1;
                        print "ERROR $file:$line no parent path $base for $arg2\n";
                    }
                }
                elsif ($cmd eq 'l') { # link arg1: original file arg2: new file
                    if (exists $paths{$arg1}) {
                        if (exists $paths{$arg2}) {
                            $error = $error + 1;
                            print "ERROR $file:$line file already exists $arg2\n";
                        }
                        else {
                            # mark it as 'f' because it is a hard link and therefore
                            # indistinguishable from the original file.
                            $paths{$arg2} = 'f';
                            print OUT "ln $arg1 $arg2\n";
                        }
                    }
                    else {
                        $error = $error + 1;
                        print "ERROR $file:$line file not found $arg1\n";
                    }
                }
                elsif ($cmd eq 'r') { # rm arg1: file
                    if (exists $paths{$arg1}) {
                        if ($paths{$arg1} eq 'f') {
                            delete $paths{$arg1};
                            print OUT "rm $arg1\n";
                        }
                        else {
                            $error = $error + 1;
                            print "ERROR $file:$line cannot remove $arg1 -- not a file\n";
                        }
                    }
                    else {
                        $error = $error + 1;
                        print "ERROR $file:$line file not found $arg1\n";
                    }
                }
                else {
                    # must be file arg1: protection arg2: dest arg3: src
                    if (exists $paths{$arg2}) {
                        $error = $error + 1;
                        print "ERROR $file:$line duplicate file $arg2\n";
                    }
                    $arg2 =~ /(.*)\/(.*)$/;
                    my $base = $1;
                    my $file = $2;
                    if (-f "$x->[0]->[0]/$arg3") {
                        if (exists($paths{$base}) or ($base eq '')) {
                            # all good
                            $paths{"$base/$file"} = 'f';
                            if ($cur_path ne $base) {
                                $base = $base eq '' ? '/' : $base;
                                print OUT "cd $base\n";
                                $cur_path = $base;
                            }
                            print OUT "bget $x->[0]->[0]/$arg3 $file\n";
                            print OUT "chmod $arg1 $file\n";
                        }
                        else {
                            $error = $error + 1;
                            print "ERROR $file:$line no parent path $base for $arg2\n";
                        }
                    }
                    else {
                        $error = $error + 1;
                        print "ERROR $file:$line file not found\n";
                    }
                }
             }
        }
    }
    close OUT;
    die "ERROR Fix errors and re-run\n" if $error;
}


# Create disk image: create empty disk, apply ucp script, run fsck.
sub build_dsk {
    my $swizzle = $args{endian} eq 'little' ? '' : '-X';
    if (system "../mkfs $swizzle $args{file} $args{isize} $args{bsize}") {
        my $status = $? >> 8;
        die "ERROR mkfs failed - exit status $status\n";
    }
    if (system "../ucp $args{file} < ucp-tmp.txt") {
        # [NAC HACK 2016Jun14] ucp bug: exit status good even tho errors occur.
        my $status = $? >> 8;
        die "ERROR ucp failed - exit status $status\n";
    }
    if (system "../fsck $args{fsck_args} $args{file}") {
        my $status = $? >> 8;
        if ($status & ~1) {
            die "ERROR fsck failed - exit status $status\n";
        }
    }
}


# Validate command-line arguments and populate %args
sub cmdline_args {
    # defaults
    $args{file} = 'fuzix.dsk';
    $args{endian} = 'little';
    $args{isize} = 256;
    $args{bsize} = 65535;
    $args{verbose} = 0;
    $args{fsck_args} = '';

    while (my $arg = shift @ARGV) {
        $arg = lc $arg;
        if ($arg eq '-h') {
            help_exit();
        }
        elsif ($arg eq '-v') {
            $args{verbose} = 1;
        }
        elsif ($arg eq '-p') {
            $args{pkg} = shift @ARGV;
        }
        elsif ($arg eq '-x') {
            $args{endian} = "big";
        }
        elsif ($arg eq '-f') {
            $args{file} = shift @ARGV;
            open OUT, ">$args{file}" or die "ERROR cannot open $args{file} for output";
            close OUT;
        }
        elsif ($arg eq '-g') {
            $args{isize} = shift @ARGV;
            $args{bsize} = shift @ARGV;
        }
	elsif ($arg eq '-y') {
	    $args{fsck_args} = '-y';
	}
        else {
            print "ERROR unrecognised option $arg -- try -h for help\n";
            exit 1;
        }
    }
}


# Display help message and exit.
sub help_exit {
    print <<EOF;

build-filesystem-ng [options]

Options:

-h           print help and exit
-v           enable more verbose output during execution

-p PKG       enable package named PKG

-x           swizzle disk image (for big-endian processors like 6809). Default: no swizzle.
-f FILENAME  filename of disk image. Default: $args{file}
-g N M       disk geometry N=inode size, M=block size. Default: $args{isize} $args{bsize}
-y           run fsck without interactive prompt

EOF
exit 1;
}
